@@ -1,5 +1,26 @@
Revision history for Lexical-Types
+0.10 2011-01-03 20:35 UTC
+ + Add : The new constant LT_FORKSAFE can be tested to know whether the
+ module will behave nicely when fork()ing. It's currently always
+ true except on Windows where you need perl 5.10.1 for it to be
+ true.
+ + Chg : perl 5.8.3 is now required (instead of 5.8.0).
+ + Fix : Scope leaks under perl 5.8-5.10.0.
+ + Fix : Segmentation faults and misbehaviours in threaded applications.
+ + Fix : Compatibility with perl 5.13.1 and higher.
+ + Fix : Broken linkage on Windows with gcc 3.4, which appears in
+ particular when using ActivePerl's default compiler suite.
+ For those setups, the autovivification shared library will now
+ be linked against the perl dll directly (instead of the import
+ library).
+ + Tst : Threads tests are now only run on perl 5.13.4 and higher.
+ They could segfault randomly because of what seems to be an
+ internal bug of Perl, which has been addressed in 5.13.4.
+ There is also an environment variable that allows you to
+ forcefully run those tests, but it should be set only for
+ author testing and not for end users.
+
0.09 2010-01-03 00:00 UTC
+ Fix : Building and testing with blead.
+ Fix : Unbalanced scopes when skipping a typed declaration.
@@ -6,6 +6,7 @@ README
Types.xs
lib/Lexical/Types.pm
ptable.h
+reap.h
samples/basic.pl
t/00-load.t
t/10-base.t
@@ -1,6 +1,6 @@
--- #YAML:1.0
name: Lexical-Types
-version: 0.09
+version: 0.10
abstract: Extend the semantics of typed lexicals.
author:
- Vincent Pit <perl@profvince.com>
@@ -16,7 +16,7 @@ build_requires:
XSLoader: 0
requires:
Carp: 0
- perl: 5.008
+ perl: 5.008003
XSLoader: 0
resources:
bugtracker: http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Lexical-Types
@@ -1,17 +1,50 @@
-use 5.008;
+use 5.008003;
use strict;
use warnings;
use ExtUtils::MakeMaker;
+BEGIN {
+ local $@;
+ eval { require Config };
+ die 'OS unsupported' if $@;
+ Config->import(qw<%Config>);
+}
+
my @DEFINES;
+my %macro;
+
+my $is_gcc_34 = 0;
+print "Checking if this is gcc 3.4 on Windows trying to link against an import library... ";
+if ($^O eq 'MSWin32' and not grep /^LD[A-Z]*=/, @ARGV) {
+ my ($libperl, $gccversion) = map $_ || '', @Config{qw<libperl gccversion>};
+ if ($gccversion =~ /^3\.4\.[0-9]+/ and $libperl =~ s/\.lib$//) {
+ $is_gcc_34 = 1;
+ my ($lddlflags, $ldflags) = @Config{qw<lddlflags ldflags>};
+ $_ ||= '', s/-L(?:".*?"|\S+)//g for $lddlflags, $ldflags;
+ $libperl = "-l$libperl";
+ my $libdirs = join ' ',
+ map { s/(?<!\\)((?:\\\\)*")/\\$1/g; qq[-L"$_"] }
+ @Config{qw<bin sitebin>};
+ $macro{LDDLFLAGS} = "$lddlflags $libdirs $libperl";
+ $macro{LDFLAGS} = "$ldflags $libdirs $libperl";
+ $macro{PERL_ARCHIVE} = '',
+ }
+}
+print $is_gcc_34 ? "yes\n" : "no\n";
# Threads, Windows and 5.8.x don't seem to be best friends
if ($^O eq 'MSWin32' && $^V lt v5.9.0) {
push @DEFINES, '-DLT_MULTIPLICITY=0';
}
+# Fork emulation got "fixed" in 5.10.1
+if ($^O eq 'MSWin32' && $^V lt v5.10.1) {
+ push @DEFINES, '-DLT_FORKSAFE=0';
+}
+
@DEFINES = (DEFINE => join ' ', @DEFINES) if @DEFINES;
+%macro = (macro => { %macro }) if %macro; # Beware of the circle
my $dist = 'Lexical-Types';
@@ -53,7 +86,7 @@ WriteMakefile(
PL_FILES => {},
@DEFINES,
PREREQ_PM => \%PREREQ_PM,
- MIN_PERL_VERSION => 5.008,
+ MIN_PERL_VERSION => 5.008003,
META_MERGE => \%META,
dist => {
PREOP => "pod2text $file > \$(DISTVNAME)/README",
@@ -61,5 +94,6 @@ WriteMakefile(
},
clean => {
FILES => "$dist-* *.gcov *.gcda *.gcno cover_db Debian_CPANTS.txt"
- }
+ },
+ %macro,
);
@@ -2,7 +2,7 @@ NAME
Lexical::Types - Extend the semantics of typed lexicals.
VERSION
- Version 0.09
+ Version 0.10
SYNOPSIS
{ package Str; }
@@ -148,7 +148,7 @@ INTEGRATION
sub import {
my $pkg = caller;
- for (qw/Str Int/) {
+ for (qw<Str Int>) {
my $type = __PACKAGE__ . '::' . $_;
no strict 'refs';
no warnings 'redefine';
@@ -176,6 +176,11 @@ CONSTANTS
True iff the module could have been built with thread-safety features
enabled.
+ "LT_FORKSAFE"
+ True iff this module could have been built with fork-safety features
+ enabled. This will always be true except on Windows where it's false for
+ perl 5.10.0 and below .
+
CAVEATS
The restrictions on the type (being either a defined package name or a
constant) apply even if you use the 'as' option to redirect to another
@@ -195,7 +200,12 @@ CAVEATS
addressed in perl 5.10.
DEPENDENCIES
- perl 5.8, XSLoader.
+ perl 5.8.3.
+
+ A C compiler. This module may happen to build with a C++ compiler as
+ well, but don't rely on it, as no guarantee is made in this regard.
+
+ XSLoader (standard since perl 5.006).
SEE ALSO
fields.
@@ -228,7 +238,7 @@ ACKNOWLEDGEMENTS
Thanks Florian Ragwitz for suggesting the use of constants for types.
COPYRIGHT & LICENSE
- Copyright 2009,2010 Vincent Pit, all rights reserved.
+ Copyright 2009,2010,2011 Vincent Pit, all rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
@@ -27,6 +27,10 @@
# define LT_WORKAROUND_REQUIRE_PROPAGATION !LT_HAS_PERL(5, 10, 1)
#endif
+#ifndef LT_HAS_RPEEP
+# define LT_HAS_RPEEP LT_HAS_PERL(5, 13, 5)
+#endif
+
#ifndef HvNAME_get
# define HvNAME_get(H) HvNAME(H)
#endif
@@ -39,16 +43,13 @@
# define SvREFCNT_inc_simple_NN SvREFCNT_inc
#endif
-#ifndef ENTER_with_name
-# define ENTER_with_name(N) ENTER
-#endif
+/* ... Thread safety and multiplicity ...................................... */
-#ifndef LEAVE_with_name
-# define LEAVE_with_name(N) LEAVE
+/* Safe unless stated otherwise in Makefile.PL */
+#ifndef LT_FORKSAFE
+# define LT_FORKSAFE 1
#endif
-/* ... Thread safety and multiplicity ...................................... */
-
#ifndef LT_MULTIPLICITY
# if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT)
# define LT_MULTIPLICITY 1
@@ -56,7 +57,8 @@
# define LT_MULTIPLICITY 0
# endif
#endif
-#if LT_MULTIPLICITY && !defined(tTHX)
+
+#ifndef tTHX
# define tTHX PerlInterpreter*
#endif
@@ -99,7 +101,7 @@
typedef struct {
SV *code;
- IV cxreq;
+ IV require_tag;
} lt_hint_t;
#define LT_HINT_STRUCT 1
@@ -141,6 +143,22 @@ typedef SV lt_hint_t;
#endif /* LT_THREADSAFE */
+/* ... "Seen" pointer table ................................................ */
+
+#if !LT_HAS_RPEEP
+
+#define PTABLE_NAME ptable_seen
+#define PTABLE_VAL_FREE(V) NOOP
+
+#include "ptable.h"
+
+/* PerlMemShared_free() needs the [ap]PTBLMS_? default values */
+#define ptable_seen_store(T, K, V) ptable_seen_store(aPTBLMS_ (T), (K), (V))
+#define ptable_seen_clear(T) ptable_seen_clear(aPTBLMS_ (T))
+#define ptable_seen_free(T) ptable_seen_free(aPTBLMS_ (T))
+
+#endif /* !LT_HAS_RPEEP */
+
/* ... Global data ......................................................... */
#define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
@@ -150,8 +168,10 @@ typedef struct {
ptable *tbl; /* It really is a ptable_hints */
tTHX owner;
#endif
+#if !LT_HAS_RPEEP
+ ptable *seen; /* It really is a ptable_seen */
+#endif
SV *default_meth;
- OP * (*pp_padsv_saved)(pTHX);
} my_cxt_t;
START_MY_CXT
@@ -160,71 +180,62 @@ START_MY_CXT
#if LT_THREADSAFE
-STATIC SV *lt_clone(pTHX_ SV *sv, tTHX owner) {
-#define lt_clone(S, O) lt_clone(aTHX_ (S), (O))
- CLONE_PARAMS param;
- AV *stashes = NULL;
- SV *dupsv;
-
- if (SvTYPE(sv) == SVt_PVHV && HvNAME_get(sv))
- stashes = newAV();
-
- param.stashes = stashes;
- param.flags = 0;
- param.proto_perl = owner;
-
- dupsv = sv_dup(sv, ¶m);
-
- if (stashes) {
- av_undef(stashes);
- SvREFCNT_dec(stashes);
- }
-
- return SvREFCNT_inc(dupsv);
-}
+typedef struct {
+ ptable *tbl;
+#if LT_HAS_PERL(5, 13, 2)
+ CLONE_PARAMS *params;
+#else
+ CLONE_PARAMS params;
+#endif
+} lt_ptable_clone_ud;
+
+#if LT_HAS_PERL(5, 13, 2)
+# define lt_ptable_clone_ud_init(U, T, O) \
+ (U).tbl = (T); \
+ (U).params = Perl_clone_params_new((O), aTHX)
+# define lt_ptable_clone_ud_deinit(U) Perl_clone_params_del((U).params)
+# define lt_dup_inc(S, U) SvREFCNT_inc(sv_dup((S), (U)->params))
+#else
+# define lt_ptable_clone_ud_init(U, T, O) \
+ (U).tbl = (T); \
+ (U).params.stashes = newAV(); \
+ (U).params.flags = 0; \
+ (U).params.proto_perl = (O)
+# define lt_ptable_clone_ud_deinit(U) SvREFCNT_dec((U).params.stashes)
+# define lt_dup_inc(S, U) SvREFCNT_inc(sv_dup((S), &((U)->params)))
+#endif
-STATIC void lt_ptable_hints_clone(pTHX_ ptable_ent *ent, void *ud_) {
- my_cxt_t *ud = ud_;
+STATIC void lt_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) {
+ lt_ptable_clone_ud *ud = ud_;
lt_hint_t *h1 = ent->val;
lt_hint_t *h2;
- if (ud->owner == aTHX)
- return;
-
#if LT_HINT_STRUCT
- h2 = PerlMemShared_malloc(sizeof *h2);
- h2->code = lt_clone(h1->code, ud->owner);
- SvREFCNT_inc(h2->code);
+ h2 = PerlMemShared_malloc(sizeof *h2);
+ h2->code = lt_dup_inc(h1->code, ud);
#if LT_WORKAROUND_REQUIRE_PROPAGATION
- h2->cxreq = h1->cxreq;
+ h2->require_tag = PTR2IV(lt_dup_inc(INT2PTR(SV *, h1->require_tag), ud));
#endif
#else /* LT_HINT_STRUCT */
- h2 = lt_clone(h1, ud->owner);
- SvREFCNT_inc(h2);
+ h2 = lt_dup_inc(h1, ud);
#endif /* !LT_HINT_STRUCT */
ptable_hints_store(ud->tbl, ent->key, h2);
}
-STATIC void lt_thread_cleanup(pTHX_ void *);
+#include "reap.h"
STATIC void lt_thread_cleanup(pTHX_ void *ud) {
- int *level = ud;
+ dMY_CXT;
- if (*level) {
- *level = 0;
- LEAVE;
- SAVEDESTRUCTOR_X(lt_thread_cleanup, level);
- ENTER;
- } else {
- dMY_CXT;
- PerlMemShared_free(level);
- ptable_hints_free(MY_CXT.tbl);
- }
+ ptable_hints_free(MY_CXT.tbl);
+#if !LT_HAS_RPEEP
+ ptable_seen_free(MY_CXT.seen);
+#endif /* !LT_HAS_RPEEP */
}
#endif /* LT_THREADSAFE */
@@ -232,30 +243,57 @@ STATIC void lt_thread_cleanup(pTHX_ void *ud) {
/* ... Hint tags ........................................................... */
#if LT_WORKAROUND_REQUIRE_PROPAGATION
+
STATIC IV lt_require_tag(pTHX) {
#define lt_require_tag() lt_require_tag(aTHX)
- const PERL_SI *si;
-
- for (si = PL_curstackinfo; si; si = si->si_prev) {
- I32 cxix;
-
- for (cxix = si->si_cxix; cxix >= 0; --cxix) {
- const PERL_CONTEXT *cx = si->si_cxstack + cxix;
-
- if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_REQUIRE)
- return PTR2IV(cx);
+ const CV *cv, *outside;
+
+ cv = PL_compcv;
+
+ if (!cv) {
+ /* If for some reason the pragma is operational at run-time, try to discover
+ * the current cv in use. */
+ const PERL_SI *si;
+
+ for (si = PL_curstackinfo; si; si = si->si_prev) {
+ I32 cxix;
+
+ for (cxix = si->si_cxix; cxix >= 0; --cxix) {
+ const PERL_CONTEXT *cx = si->si_cxstack + cxix;
+
+ switch (CxTYPE(cx)) {
+ case CXt_SUB:
+ case CXt_FORMAT:
+ /* The propagation workaround is only needed up to 5.10.0 and at that
+ * time format and sub contexts were still identical. And even later the
+ * cv members offsets should have been kept the same. */
+ cv = cx->blk_sub.cv;
+ goto get_enclosing_cv;
+ case CXt_EVAL:
+ cv = cx->blk_eval.cv;
+ goto get_enclosing_cv;
+ default:
+ break;
+ }
+ }
}
+
+ cv = PL_main_cv;
}
- return PTR2IV(NULL);
+get_enclosing_cv:
+ for (outside = CvOUTSIDE(cv); outside; outside = CvOUTSIDE(cv))
+ cv = outside;
+
+ return PTR2IV(cv);
}
+
#endif /* LT_WORKAROUND_REQUIRE_PROPAGATION */
STATIC SV *lt_tag(pTHX_ SV *value) {
#define lt_tag(V) lt_tag(aTHX_ (V))
lt_hint_t *h;
SV *code = NULL;
- dMY_CXT;
if (SvROK(value)) {
value = SvRV(value);
@@ -267,19 +305,22 @@ STATIC SV *lt_tag(pTHX_ SV *value) {
#if LT_HINT_STRUCT
h = PerlMemShared_malloc(sizeof *h);
- h->code = code;
+ h->code = code;
# if LT_WORKAROUND_REQUIRE_PROPAGATION
- h->cxreq = lt_require_tag();
+ h->require_tag = lt_require_tag();
# endif /* LT_WORKAROUND_REQUIRE_PROPAGATION */
#else /* LT_HINT_STRUCT */
h = code;
#endif /* !LT_HINT_STRUCT */
#if LT_THREADSAFE
- /* We only need for the key to be an unique tag for looking up the value later.
- * Allocated memory provides convenient unique identifiers, so that's why we
- * use the hint as the key itself. */
- ptable_hints_store(MY_CXT.tbl, h, h);
+ {
+ dMY_CXT;
+ /* We only need for the key to be an unique tag for looking up the value later
+ * Allocated memory provides convenient unique identifiers, so that's why we
+ * use the hint as the key itself. */
+ ptable_hints_store(MY_CXT.tbl, h, h);
+ }
#endif /* LT_THREADSAFE */
return newSViv(PTR2IV(h));
@@ -288,7 +329,9 @@ STATIC SV *lt_tag(pTHX_ SV *value) {
STATIC SV *lt_detag(pTHX_ const SV *hint) {
#define lt_detag(H) lt_detag(aTHX_ (H))
lt_hint_t *h;
+#if LT_THREADSAFE
dMY_CXT;
+#endif
if (!(hint && SvIOK(hint)))
return NULL;
@@ -298,7 +341,7 @@ STATIC SV *lt_detag(pTHX_ const SV *hint) {
h = ptable_fetch(MY_CXT.tbl, h);
#endif /* LT_THREADSAFE */
#if LT_WORKAROUND_REQUIRE_PROPAGATION
- if (lt_require_tag() != h->cxreq)
+ if (lt_require_tag() != h->require_tag)
return NULL;
#endif /* LT_WORKAROUND_REQUIRE_PROPAGATION */
@@ -310,7 +353,9 @@ STATIC U32 lt_hash = 0;
STATIC SV *lt_hint(pTHX) {
#define lt_hint() lt_hint(aTHX)
SV *hint;
-#if LT_HAS_PERL(5, 9, 5)
+#ifdef cop_hints_fetch_pvn
+ hint = cop_hints_fetch_pvn(PL_curcop, __PACKAGE__, __PACKAGE_LEN__, lt_hash,0);
+#elif LT_HAS_PERL(5, 9, 5)
hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
NULL,
__PACKAGE__, __PACKAGE_LEN__,
@@ -334,12 +379,23 @@ STATIC SV *lt_hint(pTHX) {
/* PerlMemShared_free() needs the [ap]PTBLMS_? default values */
#define ptable_map_store(T, K, V) ptable_map_store(aPTBLMS_ (T), (K), (V))
+#define ptable_map_delete(T, K) ptable_map_delete(aPTBLMS_ (T), (K))
STATIC ptable *lt_op_map = NULL;
#ifdef USE_ITHREADS
+
STATIC perl_mutex lt_op_map_mutex;
-#endif
+
+#define LT_LOCK(M) MUTEX_LOCK(M)
+#define LT_UNLOCK(M) MUTEX_UNLOCK(M)
+
+#else /* USE_ITHREADS */
+
+#define LT_LOCK(M)
+#define LT_UNLOCK(M)
+
+#endif /* !USE_ITHREADS */
typedef struct {
#ifdef MULTIPLICITY
@@ -357,9 +413,7 @@ STATIC void lt_map_store(pTHX_ const OP *o, SV *orig_pkg, SV *type_pkg, SV *type
#define lt_map_store(O, OP, TP, TM, PP) lt_map_store(aTHX_ (O), (OP), (TP), (TM), (PP))
lt_op_info *oi;
-#ifdef USE_ITHREADS
- MUTEX_LOCK(<_op_map_mutex);
-#endif
+ LT_LOCK(<_op_map_mutex);
if (!(oi = ptable_fetch(lt_op_map, o))) {
oi = PerlMemShared_malloc(sizeof *oi);
@@ -408,17 +462,13 @@ STATIC void lt_map_store(pTHX_ const OP *o, SV *orig_pkg, SV *type_pkg, SV *type
oi->old_pp_padsv = old_pp_padsv;
-#ifdef USE_ITHREADS
- MUTEX_UNLOCK(<_op_map_mutex);
-#endif
+ LT_UNLOCK(<_op_map_mutex);
}
STATIC const lt_op_info *lt_map_fetch(const OP *o, lt_op_info *oi) {
const lt_op_info *val;
-#ifdef USE_ITHREADS
- MUTEX_LOCK(<_op_map_mutex);
-#endif
+ LT_LOCK(<_op_map_mutex);
val = ptable_fetch(lt_op_map, o);
if (val) {
@@ -426,24 +476,18 @@ STATIC const lt_op_info *lt_map_fetch(const OP *o, lt_op_info *oi) {
val = oi;
}
-#ifdef USE_ITHREADS
- MUTEX_UNLOCK(<_op_map_mutex);
-#endif
+ LT_UNLOCK(<_op_map_mutex);
return val;
}
STATIC void lt_map_delete(pTHX_ const OP *o) {
#define lt_map_delete(O) lt_map_delete(aTHX_ (O))
-#ifdef USE_ITHREADS
- MUTEX_LOCK(<_op_map_mutex);
-#endif
+ LT_LOCK(<_op_map_mutex);
- ptable_map_store(lt_op_map, o, NULL);
+ ptable_map_delete(lt_op_map, o);
-#ifdef USE_ITHREADS
- MUTEX_UNLOCK(<_op_map_mutex);
-#endif
+ LT_UNLOCK(<_op_map_mutex);
}
/* --- Hooks --------------------------------------------------------------- */
@@ -453,114 +497,82 @@ STATIC void lt_map_delete(pTHX_ const OP *o) {
STATIC OP *lt_pp_padsv(pTHX) {
lt_op_info oi;
- if ((PL_op->op_private & OPpLVAL_INTRO) && lt_map_fetch(PL_op, &oi)) {
- PADOFFSET targ = PL_op->op_targ;
- SV *sv = PAD_SVl(targ);
-
- if (sv) {
- SV *orig_pkg, *type_pkg, *type_meth;
- int items;
- dSP;
+ if (lt_map_fetch(PL_op, &oi)) {
+ SV *orig_pkg, *type_pkg, *type_meth;
+ int items;
+ dSP;
+ dTARGET;
- ENTER;
- SAVETMPS;
+ ENTER;
+ SAVETMPS;
#ifdef MULTIPLICITY
- {
- STRLEN op_len = oi.orig_pkg_len, tp_len = oi.type_pkg_len;
- char *buf = oi.buf;
- orig_pkg = sv_2mortal(newSVpvn(buf, op_len));
- SvREADONLY_on(orig_pkg);
- buf += op_len;
- type_pkg = sv_2mortal(newSVpvn(buf, tp_len));
- SvREADONLY_on(type_pkg);
- buf += tp_len;
- type_meth = sv_2mortal(newSVpvn(buf, oi.type_meth_len));
- SvREADONLY_on(type_meth);
- }
+ {
+ STRLEN op_len = oi.orig_pkg_len, tp_len = oi.type_pkg_len;
+ char *buf = oi.buf;
+ orig_pkg = sv_2mortal(newSVpvn(buf, op_len));
+ SvREADONLY_on(orig_pkg);
+ buf += op_len;
+ type_pkg = sv_2mortal(newSVpvn(buf, tp_len));
+ SvREADONLY_on(type_pkg);
+ buf += tp_len;
+ type_meth = sv_2mortal(newSVpvn(buf, oi.type_meth_len));
+ SvREADONLY_on(type_meth);
+ }
#else /* MULTIPLICITY */
- orig_pkg = oi.orig_pkg;
- type_pkg = oi.type_pkg;
- type_meth = oi.type_meth;
+ orig_pkg = oi.orig_pkg;
+ type_pkg = oi.type_pkg;
+ type_meth = oi.type_meth;
#endif /* !MULTIPLICITY */
- PUSHMARK(SP);
- EXTEND(SP, 3);
- PUSHs(type_pkg);
- PUSHs(sv);
- PUSHs(orig_pkg);
- PUTBACK;
-
- items = call_sv(type_meth, G_ARRAY | G_METHOD);
-
- SPAGAIN;
- switch (items) {
- case 0:
- break;
- case 1:
- sv_setsv(sv, POPs);
- break;
- default:
- croak("Typed scalar initializer method should return zero or one scalar, but got %d", items);
- }
- PUTBACK;
-
- FREETMPS;
- LEAVE;
- }
-
- return CALL_FPTR(oi.old_pp_padsv)(aTHX);
- }
-
- return CALL_FPTR(PL_ppaddr[OP_PADSV])(aTHX);
-}
-
-STATIC void lt_pp_padsv_save(pMY_CXT) {
-#define lt_pp_padsv_save() lt_pp_padsv_save(aMY_CXT)
- if (MY_CXT.pp_padsv_saved)
- return;
+ PUSHMARK(SP);
+ EXTEND(SP, 3);
+ PUSHs(type_pkg);
+ PUSHTARG;
+ PUSHs(orig_pkg);
+ PUTBACK;
- MY_CXT.pp_padsv_saved = PL_ppaddr[OP_PADSV];
- PL_ppaddr[OP_PADSV] = lt_pp_padsv;
-}
+ items = call_sv(type_meth, G_ARRAY | G_METHOD);
-STATIC void lt_pp_padsv_restore(pMY_CXT_ OP *o) {
-#define lt_pp_padsv_restore(O) lt_pp_padsv_restore(aMY_CXT_ (O))
- OP *(*saved)(pTHX) = MY_CXT.pp_padsv_saved;
+ SPAGAIN;
+ switch (items) {
+ case 0:
+ break;
+ case 1:
+ sv_setsv(TARG, POPs);
+ break;
+ default:
+ croak("Typed scalar initializer method should return zero or one scalar, but got %d", items);
+ }
+ PUTBACK;
- if (!saved)
- return;
+ FREETMPS;
+ LEAVE;
- if (o->op_ppaddr == lt_pp_padsv)
- o->op_ppaddr = saved;
+ return oi.old_pp_padsv(aTHX);
+ }
- PL_ppaddr[OP_PADSV] = saved;
- MY_CXT.pp_padsv_saved = 0;
+ return PL_op->op_ppaddr(aTHX);
}
/* ... Our ck_pad{any,sv} .................................................. */
-/* Sadly, the PADSV OPs we are interested in don't trigger the padsv check
- * function, but are instead manually mutated from a PADANY. This is why we set
- * PL_ppaddr[OP_PADSV] in the padany check function so that PADSV OPs will have
- * their pp_ppaddr set to our pp_padsv. PL_ppaddr[OP_PADSV] is then reset at the
- * beginning of every ck_pad{any,sv}. Some unwanted OPs can still call our
- * pp_padsv, but much less than if we would have set PL_ppaddr[OP_PADSV]
- * globally. */
+/* Sadly, the padsv OPs we are interested in don't trigger the padsv check
+ * function, but are instead manually mutated from a padany. So we store
+ * the op entry in the op map in the padany check function, and we set their
+ * op_ppaddr member in our peephole optimizer replacement below. */
STATIC OP *(*lt_old_ck_padany)(pTHX_ OP *) = 0;
STATIC OP *lt_ck_padany(pTHX_ OP *o) {
HV *stash;
SV *code;
- dMY_CXT;
-
- lt_pp_padsv_restore(o);
- o = CALL_FPTR(lt_old_ck_padany)(aTHX_ o);
+ o = lt_old_ck_padany(aTHX_ o);
stash = PL_in_my_stash;
if (stash && (code = lt_hint())) {
+ dMY_CXT;
SV *orig_pkg = newSVpvn(HvNAME_get(stash), HvNAMELEN_get(stash));
SV *orig_meth = MY_CXT.default_meth;
SV *type_pkg = NULL;
@@ -620,9 +632,7 @@ STATIC OP *lt_ck_padany(pTHX_ OP *o) {
SvREFCNT_inc(orig_meth);
}
- lt_pp_padsv_save();
-
- lt_map_store(o, orig_pkg, type_pkg, type_meth, MY_CXT.pp_padsv_saved);
+ lt_map_store(o, orig_pkg, type_pkg, type_meth, o->op_ppaddr);
} else {
skip:
lt_map_delete(o);
@@ -634,20 +644,110 @@ skip:
STATIC OP *(*lt_old_ck_padsv)(pTHX_ OP *) = 0;
STATIC OP *lt_ck_padsv(pTHX_ OP *o) {
- dMY_CXT;
+ lt_map_delete(o);
- lt_pp_padsv_restore(o);
+ return lt_old_ck_padsv(aTHX_ o);
+}
- lt_map_delete(o);
+/* ... Our peephole optimizer .............................................. */
+
+STATIC peep_t lt_old_peep = 0; /* This is actually the rpeep past 5.13.5 */
+
+#if !LT_HAS_RPEEP
+# define LT_PEEP_REC_PROTO STATIC void lt_peep_rec(pTHX_ OP *o, ptable *seen)
+#else /* !LT_HAS_RPEEP */
+# define LT_PEEP_REC_PROTO STATIC void lt_peep_rec(pTHX_ OP *o)
+#endif /* LT_HAS_RPEEP */
+
+LT_PEEP_REC_PROTO;
+LT_PEEP_REC_PROTO {
+#if !LT_HAS_RPEEP
+# define lt_peep_rec(O) lt_peep_rec(aTHX_ (O), seen)
+#else /* !LT_HAS_RPEEP */
+# define lt_peep_rec(O) lt_peep_rec(aTHX_ (O))
+#endif /* LT_HAS_RPEEP */
+
+#if !LT_HAS_RPEEP
+ if (ptable_fetch(seen, o))
+ return;
+#endif
+
+ for (; o; o = o->op_next) {
+ lt_op_info *oi = NULL;
- return CALL_FPTR(lt_old_ck_padsv)(aTHX_ o);
+#if !LT_HAS_RPEEP
+ ptable_seen_store(seen, o, o);
+#endif
+ switch (o->op_type) {
+ case OP_PADSV:
+ if (o->op_ppaddr != lt_pp_padsv && o->op_private & OPpLVAL_INTRO) {
+ LT_LOCK(<_op_map_mutex);
+ oi = ptable_fetch(lt_op_map, o);
+ if (oi) {
+ oi->old_pp_padsv = o->op_ppaddr;
+ o->op_ppaddr = lt_pp_padsv;
+ }
+ LT_UNLOCK(<_op_map_mutex);
+ }
+ break;
+#if !LT_HAS_RPEEP
+ case OP_MAPWHILE:
+ case OP_GREPWHILE:
+ case OP_AND:
+ case OP_OR:
+ case OP_ANDASSIGN:
+ case OP_ORASSIGN:
+ case OP_COND_EXPR:
+ case OP_RANGE:
+# if LT_HAS_PERL(5, 10, 0)
+ case OP_ONCE:
+ case OP_DOR:
+ case OP_DORASSIGN:
+# endif
+ lt_peep_rec(cLOGOPo->op_other);
+ break;
+ case OP_ENTERLOOP:
+ case OP_ENTERITER:
+ lt_peep_rec(cLOOPo->op_redoop);
+ lt_peep_rec(cLOOPo->op_nextop);
+ lt_peep_rec(cLOOPo->op_lastop);
+ break;
+# if LT_HAS_PERL(5, 9, 5)
+ case OP_SUBST:
+ lt_peep_rec(cPMOPo->op_pmstashstartu.op_pmreplstart);
+ break;
+# else
+ case OP_QR:
+ case OP_MATCH:
+ case OP_SUBST:
+ lt_peep_rec(cPMOPo->op_pmreplstart);
+ break;
+# endif
+#endif /* !LT_HAS_RPEEP */
+ default:
+ break;
+ }
+ }
}
+STATIC void lt_peep(pTHX_ OP *o) {
+#if !LT_HAS_RPEEP
+ dMY_CXT;
+ ptable *seen = MY_CXT.seen;
+
+ ptable_seen_clear(seen);
+#endif /* !LT_HAS_RPEEP */
+
+ lt_old_peep(aTHX_ o);
+ lt_peep_rec(o);
+}
+
+/* --- Interpreter setup/teardown ------------------------------------------ */
+
+
STATIC U32 lt_initialized = 0;
STATIC void lt_teardown(pTHX_ void *root) {
- dMY_CXT;
-
if (!lt_initialized)
return;
@@ -656,16 +756,29 @@ STATIC void lt_teardown(pTHX_ void *root) {
return;
#endif
+ {
+ dMY_CXT;
#if LT_THREADSAFE
- ptable_hints_free(MY_CXT.tbl);
+ ptable_hints_free(MY_CXT.tbl);
#endif
- SvREFCNT_dec(MY_CXT.default_meth);
+#if !LT_HAS_RPEEP
+ ptable_seen_free(MY_CXT.seen);
+#endif
+ SvREFCNT_dec(MY_CXT.default_meth);
+ }
PL_check[OP_PADANY] = MEMBER_TO_FPTR(lt_old_ck_padany);
lt_old_ck_padany = 0;
PL_check[OP_PADSV] = MEMBER_TO_FPTR(lt_old_ck_padsv);
lt_old_ck_padsv = 0;
+#if LT_HAS_RPEEP
+ PL_rpeepp = lt_old_peep;
+#else
+ PL_peepp = lt_old_peep;
+#endif
+ lt_old_peep = 0;
+
lt_initialized = 0;
}
@@ -677,11 +790,13 @@ STATIC void lt_setup(pTHX) {
{
MY_CXT_INIT;
#if LT_THREADSAFE
- MY_CXT.tbl = ptable_new();
- MY_CXT.owner = aTHX;
+ MY_CXT.tbl = ptable_new();
+ MY_CXT.owner = aTHX;
#endif
- MY_CXT.pp_padsv_saved = 0;
- MY_CXT.default_meth = newSVpvn("TYPEDSCALAR", 11);
+#if !LT_HAS_RPEEP
+ MY_CXT.seen = ptable_new();
+#endif
+ MY_CXT.default_meth = newSVpvn("TYPEDSCALAR", 11);
SvREADONLY_on(MY_CXT.default_meth);
}
@@ -690,6 +805,14 @@ STATIC void lt_setup(pTHX) {
lt_old_ck_padsv = PL_check[OP_PADSV];
PL_check[OP_PADSV] = MEMBER_TO_FPTR(lt_ck_padsv);
+#if LT_HAS_RPEEP
+ lt_old_peep = PL_rpeepp;
+ PL_rpeepp = lt_peep;
+#else
+ lt_old_peep = PL_peepp;
+ PL_peepp = lt_peep;
+#endif
+
#if LT_MULTIPLICITY
call_atexit(lt_teardown, aTHX);
#else
@@ -721,6 +844,7 @@ BOOT:
stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1);
newCONSTSUB(stash, "LT_THREADSAFE", newSVuv(LT_THREADSAFE));
+ newCONSTSUB(stash, "LT_FORKSAFE", newSVuv(LT_FORKSAFE));
}
lt_setup();
@@ -733,31 +857,36 @@ CLONE(...)
PROTOTYPE: DISABLE
PREINIT:
ptable *t;
- int *level;
+#if !LT_HAS_RPEEP
+ ptable *s;
+#endif
SV *cloned_default_meth;
PPCODE:
{
- my_cxt_t ud;
- dMY_CXT;
- ud.tbl = t = ptable_new();
- ud.owner = MY_CXT.owner;
- ptable_walk(MY_CXT.tbl, lt_ptable_hints_clone, &ud);
- cloned_default_meth = lt_clone(MY_CXT.default_meth, MY_CXT.owner);
+ {
+ lt_ptable_clone_ud ud;
+ dMY_CXT;
+
+ t = ptable_new();
+ lt_ptable_clone_ud_init(ud, t, MY_CXT.owner);
+ ptable_walk(MY_CXT.tbl, lt_ptable_clone, &ud);
+ cloned_default_meth = lt_dup_inc(MY_CXT.default_meth, &ud);
+ lt_ptable_clone_ud_deinit(ud);
+ }
+#if !LT_HAS_RPEEP
+ s = ptable_new();
+#endif
}
{
MY_CXT_CLONE;
- MY_CXT.tbl = t;
- MY_CXT.owner = aTHX;
- MY_CXT.pp_padsv_saved = 0;
- MY_CXT.default_meth = cloned_default_meth;
- }
- {
- level = PerlMemShared_malloc(sizeof *level);
- *level = 1;
- LEAVE_with_name("sub");
- SAVEDESTRUCTOR_X(lt_thread_cleanup, level);
- ENTER_with_name("sub");
+ MY_CXT.tbl = t;
+ MY_CXT.owner = aTHX;
+#if !LT_HAS_RPEEP
+ MY_CXT.seen = s;
+#endif
+ MY_CXT.default_meth = cloned_default_meth;
}
+ reap(3, lt_thread_cleanup, NULL);
XSRETURN(0);
#endif
@@ -1,25 +1,23 @@
package Lexical::Types;
-use 5.008;
+use 5.008003;
use strict;
use warnings;
-use Carp qw/croak/;
-
=head1 NAME
Lexical::Types - Extend the semantics of typed lexicals.
=head1 VERSION
-Version 0.09
+Version 0.10
=cut
our $VERSION;
BEGIN {
- $VERSION = '0.09';
+ $VERSION = '0.10';
}
=head1 SYNOPSIS
@@ -152,7 +150,8 @@ sub import {
$as .= '::' if $as !~ /::$/;
$hint = _tag(sub { $as . $_[0] });
} else {
- croak "Invalid $r reference for 'as'";
+ require Carp;
+ Carp::croak("Invalid $r reference for 'as'");
}
} else {
$hint = _tag(sub { @_ });
@@ -222,7 +221,7 @@ If you prefer to use constants rather than creating empty packages, you can repl
sub import {
my $pkg = caller;
- for (qw/Str Int/) {
+ for (qw<Str Int>) {
my $type = __PACKAGE__ . '::' . $_;
no strict 'refs';
no warnings 'redefine';
@@ -251,6 +250,11 @@ If you prefer to use constants rather than creating empty packages, you can repl
True iff the module could have been built with thread-safety features enabled.
+=head2 C<LT_FORKSAFE>
+
+True iff this module could have been built with fork-safety features enabled.
+This will always be true except on Windows where it's false for perl 5.10.0 and below .
+
=head1 CAVEATS
The restrictions on the type (being either a defined package name or a constant) apply even if you use the C<'as'> option to redirect to another package, and are unlikely to find a workaround as this happens deep inside the lexer - far from the reach of an extension.
@@ -264,7 +268,12 @@ This is due to a shortcoming in the way perl handles the hints hash, which is ad
=head1 DEPENDENCIES
-L<perl> 5.8, L<XSLoader>.
+L<perl> 5.8.3.
+
+A C compiler.
+This module may happen to build with a C++ compiler as well, but don't rely on it, as no guarantee is made in this regard.
+
+L<XSLoader> (standard since perl 5.006).
=head1 SEE ALSO
@@ -298,7 +307,7 @@ Thanks Florian Ragwitz for suggesting the use of constants for types.
=head1 COPYRIGHT & LICENSE
-Copyright 2009,2010 Vincent Pit, all rights reserved.
+Copyright 2009,2010,2011 Vincent Pit, all rights reserved.
This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
@@ -9,6 +9,13 @@
/* This header is designed to be included several times with different
* definitions for PTABLE_NAME and PTABLE_VAL_FREE(). */
+#undef VOID2
+#ifdef __cplusplus
+# define VOID2(T, P) static_cast<T>(P)
+#else
+# define VOID2(T, P) (P)
+#endif
+
#undef pPTBLMS
#undef pPTBLMS_
#undef aPTBLMS
@@ -22,7 +29,7 @@
# define aPTBLMS aTHX
# define aPTBLMS_ aTHX_
#else
-# define pPTBLMS
+# define pPTBLMS void
# define pPTBLMS_
# define aPTBLMS
# define aPTBLMS_
@@ -79,10 +86,11 @@ typedef struct ptable {
#ifndef ptable_new
STATIC ptable *ptable_new(pPTBLMS) {
#define ptable_new() ptable_new(aPTBLMS)
- ptable *t = PerlMemShared_malloc(sizeof *t);
- t->max = 15;
- t->items = 0;
- t->ary = PerlMemShared_calloc(t->max + 1, sizeof *t->ary);
+ ptable *t = VOID2(ptable *, PerlMemShared_malloc(sizeof *t));
+ t->max = 15;
+ t->items = 0;
+ t->ary = VOID2(ptable_ent **,
+ PerlMemShared_calloc(t->max + 1, sizeof *t->ary));
return t;
}
#endif /* !ptable_new */
@@ -125,7 +133,7 @@ STATIC void ptable_split(pPTBLMS_ ptable * const t) {
size_t newsize = oldsize * 2;
size_t i;
- ary = PerlMemShared_realloc(ary, newsize * sizeof(*ary));
+ ary = VOID2(ptable_ent **, PerlMemShared_realloc(ary, newsize * sizeof(*ary)));
Zero(&ary[oldsize], newsize - oldsize, sizeof(*ary));
t->max = --newsize;
t->ary = ary;
@@ -157,7 +165,7 @@ STATIC void PTABLE_PREFIX(_store)(pPTBL_ ptable * const t, const void * const ke
ent->val = val;
} else if (val) {
const size_t i = PTABLE_HASH(key) & t->max;
- ent = PerlMemShared_malloc(sizeof *ent);
+ ent = VOID2(ptable_ent *, PerlMemShared_malloc(sizeof *ent));
ent->key = key;
ent->val = val;
ent->next = t->ary[i];
@@ -168,6 +176,27 @@ STATIC void PTABLE_PREFIX(_store)(pPTBL_ ptable * const t, const void * const ke
}
}
+STATIC void PTABLE_PREFIX(_delete)(pPTBL_ ptable * const t, const void * const key) {
+ ptable_ent *prev, *ent;
+ const size_t i = PTABLE_HASH(key) & t->max;
+
+ prev = NULL;
+ ent = t->ary[i];
+ for (; ent; prev = ent, ent = ent->next) {
+ if (ent->key == key)
+ break;
+ }
+
+ if (ent) {
+ if (prev)
+ prev->next = ent->next;
+ else
+ t->ary[i] = ent->next;
+ PTABLE_VAL_FREE(ent->val);
+ PerlMemShared_free(ent);
+ }
+}
+
#ifndef ptable_walk
STATIC void ptable_walk(pTHX_ ptable * const t, void (*cb)(pTHX_ ptable_ent *ent, void *userdata), void *userdata) {
#define ptable_walk(T, CB, UD) ptable_walk(aTHX_ (T), (CB), (UD))
@@ -177,7 +206,8 @@ STATIC void ptable_walk(pTHX_ ptable * const t, void (*cb)(pTHX_ ptable_ent *ent
do {
ptable_ent *entry;
for (entry = array[i]; entry; entry = entry->next)
- cb(aTHX_ entry, userdata);
+ if (entry->val)
+ cb(aTHX_ entry, userdata);
} while (i--);
}
}
@@ -0,0 +1,81 @@
+/* This file is part of the Lexical::Types Perl module.
+ * See http://search.cpan.org/dist/Lexical-Types/ */
+
+/* This header provides a specialized version of Scope::Upper::reap that can be
+ * called directly from XS.
+ * See http://search.cpan.org/dist/Scope-Upper/ for details. */
+
+#ifndef REAP_H
+#define REAP_H 1
+
+#define REAP_DESTRUCTOR_SIZE 3
+
+typedef struct {
+ I32 depth;
+ I32 *origin;
+ void (*cb)(pTHX_ void *);
+ void *ud;
+ char *dummy;
+} reap_ud;
+
+STATIC void reap_pop(pTHX_ void *);
+
+STATIC void reap_pop(pTHX_ void *ud_) {
+ reap_ud *ud = ud_;
+ I32 depth, *origin, mark, base;
+
+ depth = ud->depth;
+ origin = ud->origin;
+ mark = origin[depth];
+ base = origin[depth - 1];
+
+ if (base < mark) {
+ PL_savestack_ix = mark;
+ leave_scope(base);
+ }
+ PL_savestack_ix = base;
+
+ if ((ud->depth = --depth) > 0) {
+ SAVEDESTRUCTOR_X(reap_pop, ud);
+ } else {
+ void (*cb)(pTHX_ void *) = ud->cb;
+ void *cb_ud = ud->ud;
+
+ PerlMemShared_free(ud->origin);
+ PerlMemShared_free(ud);
+
+ SAVEDESTRUCTOR_X(cb, cb_ud);
+ }
+}
+
+STATIC void reap(pTHX_ I32 depth, void (*cb)(pTHX_ void *), void *cb_ud) {
+#define reap(D, CB, UD) reap(aTHX_ (D), (CB), (UD))
+ reap_ud *ud;
+ I32 i;
+
+ if (depth > PL_scopestack_ix)
+ depth = PL_scopestack_ix;
+
+ ud = PerlMemShared_malloc(sizeof *ud);
+ ud->depth = depth;
+ ud->origin = PerlMemShared_malloc((depth + 1) * sizeof *ud->origin);
+ ud->cb = cb;
+ ud->ud = cb_ud;
+ ud->dummy = NULL;
+
+ for (i = depth; i >= 1; --i) {
+ I32 j = PL_scopestack_ix - i;
+ ud->origin[depth - i] = PL_scopestack[j];
+ PL_scopestack[j] += REAP_DESTRUCTOR_SIZE;
+ }
+ ud->origin[depth] = PL_savestack_ix;
+
+ while (PL_savestack_ix + REAP_DESTRUCTOR_SIZE
+ <= PL_scopestack[PL_scopestack_ix - 1]) {
+ save_pptr(&ud->dummy);
+ }
+
+ SAVEDESTRUCTOR_X(reap_pop, ud);
+}
+
+#endif /* REAP_H */
@@ -88,7 +88,7 @@ use Test::More tests => 14 + 6;
my $expect = qr/^Invalid ARRAY reference/;
local $@;
eval q[
- use Lexical::Types as => [ qw/a b c/ ];
+ use Lexical::Types as => [ qw<a b c> ];
my LTT $x;
];
like $@, $expect, 'as => array';
@@ -99,7 +99,7 @@ use Test::More tests => 14 + 6;
diag 'This will throw two warnings' if $] >= 5.008008 and $] < 5.009;
local $@;
eval q[
- use Lexical::Types as => sub { qw/a b c/ };
+ use Lexical::Types as => sub { qw<a b c> };
my LTT $x;
];
like $@, $expect, 'as => code, returning three scalars';
@@ -3,7 +3,7 @@
use strict;
use warnings;
-use Config qw/%Config/;
+use Config qw<%Config>;
use Test::More tests => 4;
@@ -26,7 +26,7 @@ use lib 't/lib';
sub cb3 { push @decls, $_[0]; @_ }
{
no strict 'refs';
- *{"Int3$_\::TYPEDSCALAR"} = \&Int::TYPEDSCALAR for qw/X Y Z/;
+ *{"Int3$_\::TYPEDSCALAR"} = \&Int::TYPEDSCALAR for qw<X Y Z>;
}
local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ };
eval <<' TESTREQUIRED3';
@@ -42,6 +42,6 @@ use lib 't/lib';
@w = grep !/^warn:Attempt\s+to\s+free\s+unreferenced/, @w if $] <= 5.008003;
is $@, '', 'third require test didn\'t croak prematurely';
is_deeply \@w, [ ], 'third require test didn\'t warn';
- is_deeply \@decls, [ map "Int3$_", qw/X Z/ ],
+ is_deeply \@decls, [ map "Int3$_", qw<X Z> ],
'third require test propagated in the right scopes';
}
@@ -13,7 +13,7 @@ BEGIN {
{
package Lexical::Types::Test::Str;
- use Variable::Magic qw/wizard cast/;
+ use Variable::Magic qw<wizard cast>;
our $wiz;
BEGIN {
@@ -40,7 +40,8 @@ sub check (&$$;$) {
my $want = wantarray;
my @ret;
{
- local @{$got}{qw/get set/}; delete @{$got}{qw/get set/};
+ local @{$got}{qw<get set>};
+ delete @{$got}{qw<get set>};
if ($want) {
@ret = eval { $test->() };
} elsif (defined $want) {
@@ -13,7 +13,7 @@ BEGIN {
{
package Lexical::Types::Test::Ref;
- use Variable::Magic qw/wizard cast/;
+ use Variable::Magic qw<wizard cast>;
our $wiz;
BEGIN {
@@ -45,7 +45,8 @@ sub check (&$$;$) {
my $want = wantarray;
my @ret;
{
- local @{$got}{qw/fetch store/}; delete @{$got}{qw/fetch store/};
+ local @{$got}{qw<fetch store>};
+ delete @{$got}{qw<fetch store>};
if ($want) {
@ret = eval { $test->() };
} elsif (defined $want) {
@@ -3,14 +3,20 @@
use strict;
use warnings;
-use Config qw/%Config/;
+sub skipall {
+ my ($msg) = @_;
+ require Test::More;
+ Test::More::plan(skip_all => $msg);
+}
+
+use Config qw<%Config>;
BEGIN {
- if (!$Config{useithreads}) {
- require Test::More;
- Test::More->import;
- plan(skip_all => 'This perl wasn\'t built to support threads');
- }
+ my $force = $ENV{PERL_LEXICAL_TYPES_TEST_THREADS} ? 1 : !1;
+ skipall 'This perl wasn\'t built to support threads'
+ unless $Config{useithreads};
+ skipall 'perl 5.13.4 required to test thread safety'
+ unless $force or $] >= 5.013004;
}
use threads;
@@ -19,12 +25,10 @@ use Test::More;
BEGIN {
require Lexical::Types;
- if (Lexical::Types::LT_THREADSAFE()) {
- plan tests => 10 * 2 * 3 * (1 + 2);
- defined and diag "Using threads $_" for $threads::VERSION;
- } else {
- plan skip_all => 'This Lexical::Types isn\'t thread safe';
- }
+ skipall 'This Lexical::Types isn\'t thread safe'
+ unless Lexical::Types::LT_THREADSAFE();
+ plan tests => 10 * 2 * 3 * (1 + 2);
+ defined and diag "Using threads $_" for $threads::VERSION;
}
{
@@ -3,14 +3,20 @@
use strict;
use warnings;
-use Config qw/%Config/;
+sub skipall {
+ my ($msg) = @_;
+ require Test::More;
+ Test::More::plan(skip_all => $msg);
+}
+
+use Config qw<%Config>;
BEGIN {
- if (!$Config{useithreads}) {
- require Test::More;
- Test::More->import;
- plan(skip_all => 'This perl wasn\'t built to support threads');
- }
+ my $force = $ENV{PERL_LEXICAL_TYPES_TEST_THREADS} ? 1 : !1;
+ skipall 'This perl wasn\'t built to support threads'
+ unless $Config{useithreads};
+ skipall 'perl 5.13.4 required to test thread safety'
+ unless $force or $] >= 5.013004;
}
use threads;
@@ -19,18 +25,19 @@ use Test::More;
BEGIN {
require Lexical::Types;
- if (Lexical::Types::LT_THREADSAFE()) {
- plan tests => 1;
- defined and diag "Using threads $_" for $threads::VERSION;
- } else {
- plan skip_all => 'This Lexical::Types isn\'t thread safe';
- }
+ skipall 'This Lexical::Types isn\'t thread safe'
+ unless Lexical::Types::LT_THREADSAFE();
+ plan tests => 1;
+ defined and diag "Using threads $_" for $threads::VERSION;
}
sub run_perl {
my $code = shift;
+ my $SystemRoot = $ENV{SystemRoot};
local %ENV;
+ $ENV{SystemRoot} = $SystemRoot if $^O eq 'MSWin32' and defined $SystemRoot;
+
system { $^X } $^X, '-T', map("-I$_", @INC), '-e', $code;
}
@@ -48,11 +55,11 @@ SKIP:
}
use threads;
$code = threads->create(sub {
- $code = @expected = qw/IntX/;
+ $code = @expected = qw<IntX>;
eval q{use Lexical::Types as => \&cb; my IntX $x;}; die if $@;
return $code;
})->join;
- $code += @expected = qw/IntZ/;
+ $code += @expected = qw<IntZ>;
eval q{my IntY $y;}; die if $@;
eval q{use Lexical::Types as => \&cb; my IntZ $z;}; die if $@;
$code += 256 if $code < 0;